home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Smltop.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  10.3 KB  |  302 lines  |  [TEXT/R*ch]
  1. (* Smltop.sml *)
  2.  
  3. open List Obj BasicIO Nonstdio;
  4. open Miscsys Memory Fnlib Config Mixture Const Smlexc Smlprim;
  5. open Globals Location Units Types Smlperv Code_dec Emitcode Emit_phr Compiler;
  6. open Symtable Patch;
  7. open Rtvals Load_phr Exec_phr;
  8.  
  9. exception Already of string
  10. and NotYet of string
  11.  
  12. fun add_suffix name suffix =
  13.   if Filename.check_suffix name suffix
  14.   then (Filename.chop_suffix name suffix, name)
  15.   else (name, name ^ suffix)
  16. ;
  17.  
  18. (* Loading in core a compiled bytecode file *)
  19.  
  20. fun tryEvalLoad name =
  21.   let
  22.     val (simplename, filename) = add_suffix name ".uo"
  23.     val uname = normalizedUnitName(Filename.basename simplename)
  24.     val () =
  25.       if member uname reservedUnitNames then
  26.         raise Fail ("load: cannot load built-in unit "^uname)
  27.       else ()
  28.     val () =
  29.       (ignore (Hasht.find (!watchDog) uname);
  30.        raise Already uname)
  31.       handle Subscript => ()
  32.     val block_len = ref 0
  33.     val code = ref ""
  34.     val truename = find_in_path filename
  35.     val is = open_in_bin truename
  36.     val () =
  37.       let
  38.         val stop = input_binary_int is
  39.         val start = pos_in is
  40.         val code_len = stop - start
  41.         val () = (block_len := code_len + 1)
  42.         (* Now we have to check, whether the unit body is compatible *)
  43.         (* with its compiled signature and previously loaded units. *)
  44.         val () = seek_in is stop
  45.         val tables = (input_value is : compiled_unit_tables)
  46.         val () =
  47.           Hasht.apply (fn uname' => fn stamp' =>
  48.               let val stamp'' = Hasht.find (!watchDog) uname' in
  49.                 if stamp'' <> stamp' then
  50.                   raise Fail ("load: compiled body of unit "^uname^
  51.                      " is incompatible with previously loaded unit "^
  52.                      uname')
  53.                 else ()
  54.               end
  55.               handle Subscript => raise NotYet uname')
  56.             (#cu_mentions tables)
  57.         (* The following line will cause the compiled signature *)
  58.         (* to be put into the current table of unit signatures (if not there)! *)
  59.         val sign = (Hasht.find (!currentSigTable) uname
  60.                    handle Subscript => readSig uname)
  61.         prim_val set_nth_char_ : string -> int -> char -> unit
  62.                                                  = 3 "set_nth_char"
  63.       in
  64.         if #cu_sig_stamp tables <> getOption (!(#uStamp sign)) then
  65.            raise Fail ("load: compiled body of unit "^uname^
  66.                        " is incompatible with its compiled signature")
  67.         else ();
  68.         seek_in is start;
  69.         code := static_alloc (!block_len);
  70.         fast_really_input is (!code) 0 code_len;
  71.         (* `set_nth_char' must not check the length of buff, *)
  72.         (* because `code' is allocated outside the heap! *)
  73.         set_nth_char_ (!code) code_len (Char.chr Opcodes.STOP);
  74.         app
  75.           (fn phr =>
  76.             patch_object (!code) ((#cph_pos phr) - start) (#cph_reloc phr))
  77.           (rev (#cu_phrase_index tables));
  78.         exportPublicNames uname
  79.           (#cu_exc_ren_list tables) (#cu_val_ren_list tables);
  80.         Hasht.insert (!currentSigTable) uname sign;
  81.         Hasht.insert (!watchDog) uname (#cu_sig_stamp tables);
  82.         close_in is
  83.       end
  84.       handle x =>
  85.         (close_in is; raise x)
  86.     val res = do_code false (!code) 0 (!block_len)
  87.   in () end
  88. ;
  89.  
  90. fun evalLoad s =
  91.   (catch_interrupt false; tryEvalLoad s; catch_interrupt true)
  92.   handle
  93.        SysErr(s, _) =>
  94.          (catch_interrupt true; raise Fail ("load: "^s))
  95.      | Already uname =>
  96.          (catch_interrupt true;
  97.       raise Fail ("load: unit "^uname^" has been loaded already"))
  98.      | NotYet uname =>
  99.          (catch_interrupt true;
  100.       raise Fail ("load: unit "^uname^" is needed but not yet loaded"))
  101.      | Out_of_memory =>
  102.          (catch_interrupt true; raise Fail "load: out of memory")
  103.      | Toplevel =>
  104.          (catch_interrupt true;
  105.           raise Fail "load: unable to load")
  106.      | x => (catch_interrupt true; raise x)
  107. ;
  108.  
  109. (* A more user-friendly load function:
  110.    * does not fail when a unit has already been loaded;
  111.    * automatically loads any unit that a requested unit depends on.
  112. *)
  113.  
  114. fun smartEvalLoad s =
  115.     let fun tryload s pending =
  116.     (catch_interrupt false; tryEvalLoad s; catch_interrupt true)
  117.     handle
  118.     SysErr(s, _) =>
  119.         (catch_interrupt true; raise Fail ("load: "^s))
  120.       | Already _ =>
  121.         catch_interrupt true
  122.       | NotYet missing =>
  123.         (catch_interrupt true;
  124.          if member missing pending then
  125.          raise Fail ("load: unit " ^ missing ^
  126.                  " indirectly depends on itself")
  127.          else
  128.          (tryload missing (s :: pending);
  129.           tryload s pending))
  130.       | Out_of_memory =>
  131.         (catch_interrupt true; raise Fail "load: out of memory")
  132.       | Toplevel =>
  133.         (catch_interrupt true;
  134.          raise Fail "load: unable to load")
  135.       | x => (catch_interrupt true; raise x)
  136.     in tryload s [] end
  137. ;
  138.  
  139. fun protect_current_input fct =
  140.   let val saved_input_name = !input_name
  141.       and saved_input_stream = !input_stream
  142.       and saved_input_lexbuf = !input_lexbuf
  143.   in
  144.     (fct();
  145.      input_lexbuf := saved_input_lexbuf;
  146.      input_stream := saved_input_stream;
  147.      input_name := saved_input_name)
  148.     handle x =>
  149.       (input_lexbuf := saved_input_lexbuf;
  150.        input_stream := saved_input_stream;
  151.        input_name := saved_input_name;
  152.        raise x)
  153.   end
  154. ;
  155.  
  156. (* Loading an SML source file *)
  157.  
  158. fun loadToplevelPhrase lexbuf =
  159.   let val (phrase, isLast) = parseToplevelPhrase lexbuf in
  160.     execToplevelPhrase phrase;
  161.     isLast
  162.   end
  163. ;
  164.  
  165. fun evalUse filename =
  166.   let
  167.     val truename =
  168.       (find_in_path filename
  169.        handle Fail msg =>
  170.          (msgIBlock 0; errPrompt msg; msgEOL(); msgEBlock(); msgFlush();
  171.           raise Toplevel))
  172.     val () = (msgIBlock 0;
  173.               msgString "[opening file \""; msgString truename;
  174.               msgString "\"]"; msgEOL(); msgEBlock(); msgFlush())
  175.     val is = open_in_bin truename
  176.     val lexbuf = Compiler.createLexerStream is
  177.     fun closeIn() =
  178.       (close_in is;
  179.        msgIBlock 0;
  180.        msgString "[closing file \""; msgString truename;
  181.        msgString "\"]"; msgEOL(); msgEBlock(); msgFlush())
  182.   in
  183.     ( protect_current_input (fn () =>
  184.         (input_name := truename;
  185.          input_stream := is;
  186.          input_lexbuf := lexbuf;
  187.          while true do
  188.            let val isLast = loadToplevelPhrase lexbuf
  189.            in if isLast then raise EndOfFile else () end)))
  190.     handle
  191.         EndOfFile => closeIn()
  192.       | x => (closeIn(); raise x)
  193.   end
  194. ;
  195.  
  196. (* Compile a file *)
  197.  
  198. fun tryEvalCompile s =
  199.   protect_current_input (fn () => protectCurrentUnit (fn () =>
  200.     if Filename.check_suffix s ".sig" then
  201.       let val filename = Filename.chop_suffix s ".sig" in
  202.         compileSignature
  203.           (normalizedUnitName (Filename.basename filename))
  204.           filename
  205.       end
  206.     else if Filename.check_suffix s ".sml" then
  207.       let val filename = Filename.chop_suffix s ".sml" in
  208.         compileUnitBody
  209.           (normalizedUnitName (Filename.basename filename))
  210.           filename
  211.       end
  212.     else
  213.       raise Fail "compile: unknown file name extension"))
  214. ;
  215.  
  216. fun evalCompile s =
  217.   tryEvalCompile s
  218.   handle
  219.        Interrupt => raise Fail "compile: interrupted by the user"
  220.      | Out_of_memory => raise Fail "compile: out of memory"
  221.      | Toplevel => raise Fail "compile: error(s) in the source program"
  222. ;
  223.  
  224. val smltop_con_basis =
  225. [
  226.   ("use",    { qualid={qual="Meta", id="use"},       info=VARname REGULARo}),
  227.   ("load",   { qualid={qual="Meta", id="load"},      info=VARname REGULARo}),
  228.   ("loadOne",{ qualid={qual="Meta", id="loadOne"},   info=VARname REGULARo}),
  229.   ("compile",{ qualid={qual="Meta", id="compile"},   info=VARname REGULARo}),
  230.   ("verbose",{ qualid={qual="Meta", id="verbose"},   info=VARname REGULARo}),
  231.   ("quotation",
  232.              { qualid={qual="Meta", id="quotation"}, info=VARname REGULARo}),
  233.   ("valuepoly",
  234.              { qualid={qual="Meta", id="valuepoly"}, info=VARname REGULARo}),
  235.   ("exnName",
  236.              { qualid={qual="Meta", id="exnName"},   info=VARname REGULARo}),
  237.   ("exnMessage",
  238.              { qualid={qual="Meta", id="exnMessage"},info=VARname REGULARo}),
  239.   ("printVal", { qualid={qual="Meta", id="printVal"},info=VARname OVL1TXXo}),
  240.   ("printDepth",
  241.              { qualid={qual="Meta", id="printDepth"},info=VARname REGULARo}),
  242.   ("printLength",
  243.              { qualid={qual="Meta", id="printLength"}, info=VARname REGULARo}),
  244.   ("system", { qualid={qual="Meta", id="system"},
  245.                info=PRIMname (mkPrimInfo 1 (MLPccall(1, "sml_system"))) }),
  246.   ("quit",   { qualid={qual="Meta", id="quit"},    info=VARname REGULARo}),
  247.   ("installPP",
  248.              { qualid={qual="Meta", id="installPP"}, info=VARname OVL1TPUo})
  249. ];
  250.  
  251. val smltop_VE =
  252. [
  253.    ("use",         trivial_scheme(type_arrow type_string type_unit)),
  254.    ("load",        trivial_scheme(type_arrow type_string type_unit)),
  255.    ("loadOne",     trivial_scheme(type_arrow type_string type_unit)),
  256.    ("compile",     trivial_scheme(type_arrow type_string type_unit)),
  257.    ("verbose",     trivial_scheme(type_ref type_bool)),
  258.    ("quotation",   trivial_scheme(type_ref type_bool)),
  259.    ("valuepoly",   trivial_scheme(type_ref type_bool)),
  260.    ("exnName",     trivial_scheme (type_arrow type_exn type_string)),
  261.    ("exnMessage",  trivial_scheme (type_arrow type_exn type_string)),
  262.    ("printDepth",  trivial_scheme (type_ref type_int)),
  263.    ("printLength", trivial_scheme (type_ref type_int)),
  264.    ("system",      trivial_scheme(type_arrow type_string type_int)),
  265.    ("quit",        trivial_scheme(type_arrow type_unit type_unit))
  266. ];
  267.  
  268. val unit_smltop = newSig "Meta";
  269.  
  270. val () =
  271.   app
  272.     (fn (id, status) => Hasht.insert (#uConBasis unit_smltop) id status)
  273.     smltop_con_basis
  274. ;
  275.  
  276. val () =
  277.   app
  278.     (fn (id, sc) => Hasht.insert (#uVarEnv unit_smltop) id sc)
  279.     smltop_VE
  280. ;
  281.  
  282. val () = Hasht.insert pervSigTable "Meta" unit_smltop;
  283.  
  284. fun resetSMLTopDynEnv() =
  285.   loadGlobalDynEnv "Meta" [
  286.     ("use",         repr (evalUse: string -> unit)),
  287.     ("loadOne",     repr evalLoad),
  288.     ("load",        repr smartEvalLoad),
  289.     ("compile",     repr evalCompile),
  290.     ("verbose",     repr verbose),
  291.     ("quotation",   repr Lexer.quotation),
  292.     ("valuepoly",   repr Mixture.value_polymorphism),
  293.     ("printVal",    repr evalPrint),
  294.     ("exnName",     repr Rtvals.getExnName),
  295.     ("exnMessage",  repr Rtvals.getExnMessage),
  296.     ("printDepth",  repr printDepth),
  297.     ("printLength", repr printLength),
  298.     ("quit",        repr (fn () => (msgFlush(); BasicIO.exit 0))),
  299.     ("installPP",   repr evalInstallPP)
  300. ];
  301.  
  302.